#lang rosetta-racket


(provide tholos)


(define (abacus width height)
  (box width width height))

(define (echinus top-radius bottom-radius height)
  (cone-frustum bottom-radius height top-radius))

(define (shaft top-radius bottom-radius height)
  (cone-frustum bottom-radius height top-radius))

(define-shape (doric-column .. top-w m-r b-r a-h e-h s-h)
  (let ((shaft (shaft m-r b-r s-h))
        (echinus (echinus (/ top-w 2) m-r e-h))
        (abacus (abacus top-w a-h)))
    (on-top abacus echinus shaft)))

(define (base r (h 1) (n 3))
  (on-top
   (map
    (λ (n)
      (cylinder (+ r (* n h)) h))
    (: < 1 .. < n > >))))

(define-shape (circle-placement radius n ..)
  (map
   (λ (segment) (segment-cs segment (doric-column ..)))
   (cut (par (circle radius)) n)))

(define-shape (tholos base-r n-columns edge-distance .. top-w m-r b-r a-h e-h s-h)
  (on-top
   (union (circle-placement (- base-r 0.1) n-columns ..))
   (base base-r)))

; (tholos 10 10 0.1 #:top-w 2 #:m-r 0.8 #:b-r 1 #:a-h 0.5 #:e-h 0.5 #:s-h 10)

(define-syntax (call-shape stx)
  (syntax-case stx ()
    ((_ fn . args)
     (let ((pos-args 
     (fn
         